;;; 
;;; carcdr.lisp
;;; 
;;;  3:58pm Monday,17 September 2007

(in-package #:maclisp-compat.setagaya.mc)
(export '(def-carcdr))

(defmacro def-carcdr (&body exprs)
  `(progn
     ,@(mapcar (lambda (ex)
		 (multiple-value-bind (body name)
		     (compose-CarCdr-expr ex 'lst)
		   `(defun ,name (lst) ,body)))
	       exprs)))

(defun decompose-carcdr-expr (expr)
  (let ((char-lst (map 'list (lambda (x) 
			       (intern (string x)))
		       (string-upcase (string expr)))))
    (or (and (< 7 (length char-lst))
	     (eq 'c (car char-lst)) 
	     (pop char-lst)
	     (eq 'r (car (setq char-lst (nreverse char-lst))))
	     (pop char-lst)
	     (null (remove-if (lambda (x) (or (eq 'a x) (eq 'd x)))
			      char-lst)))
	(error "Invalid name for decompose-CarCdr-expr."))
    (nreverse char-lst)))

(defun compose-carcdr-expr (expr body)
  (values 
   (reduce (lambda (x res)
	     `(,(if (eq 'a x) 'car 'cdr)
		,res))
	   (decompose-CarCdr-expr expr)
	   :initial-value body
	   :from-end 'T)
   expr))


#|
;; usage:
 (def-carcdr
     cadddddaaadadadadaaadaddddaaadddaaddaaadaaddaaddaaddadaadr
     caaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar)

 (caaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaar 
 '(((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((hello!))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|#